home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Source Code / Peter Lewis / FetchNews 1.0.0b / source / MyUtils.unit < prev    next >
Encoding:
Text File  |  1993-03-10  |  9.1 KB  |  435 lines  |  [TEXT/PJMM]
  1. unit MyUtils;
  2.  
  3. interface
  4.  
  5.     type
  6.         versionRecord = packed record
  7.                 version: integer;
  8.                 devcode: byte;
  9.                 revision: byte;
  10.                 country: integer;
  11.                 short: str15;
  12.                 long: str255;
  13.                 name: str63;
  14.             end;
  15.  
  16.     function TrapAvailable (tNumber: INTEGER): BOOLEAN;
  17.     function MyNumToString (n: longInt): str255;
  18.     function NumToStr (n: longInt): str255;
  19.     function NN (n: longInt; len: integer): str31;
  20.     function StrToNum (s: str255): longInt;
  21.     procedure DotDotDot (var s: str255; var width: integer);
  22.     procedure SetItemEnable (mh: menuHandle; item: integer; enable: boolean);
  23.     procedure SetIDItemEnable (menu, item: integer; enable: boolean);
  24.     function GetIDItemEnable (menu, item: integer): boolean;
  25.     function GetItemEnable (mh: menuHandle; item: integer): boolean;
  26.     procedure DotItem (mh: menuHandle; item: integer; dotted: boolean);
  27.     function MyFrontWindow: boolean;
  28.     function DAFrontWindow: boolean;
  29.     function GetIndStrSize (size, id, index: integer): str255;
  30.     procedure GetVersion (var vers: versionRecord);
  31.     procedure SetVersionParamText (c3: str255);
  32.     function GetDirID (wdrn: integer; var vrn: integer; var dirID: longInt): OSErr;
  33.     function GetVolInfo (var name: str63; var vrn: integer; index: integer; var CrDate: longInt): OSErr;
  34.     procedure PlotSICN (id: integer; index, v, h: integer);
  35.     function HLockState (h: univ handle): signedByte;
  36.     function LookupStrh (id: integer; match: str255): str255;
  37.     function LookupStrhNumber (id: integer; n: longInt): str255;
  38.     function TouchDir (fs: FSSpec): OSErr;
  39.     function CreateUniqueFile (var fs: FSSpec; creator, ftype: OSType): OSErr;
  40.     function MyFSWrite (refnum: integer; len: longInt; p: ptr): OSErr;
  41.  
  42.     procedure SegmentInit;
  43.     procedure SegmentUtil;
  44.     procedure SegmentUtil2;
  45.     procedure SegmentTerm;
  46.  
  47. implementation
  48.  
  49.     uses
  50.         MyTypes, Traps, Folders;
  51.  
  52. {$S Init}
  53.     procedure SegmentInit;
  54.     begin
  55.     end;
  56.  
  57. {$S Util}
  58.     procedure SegmentUtil;
  59.     begin
  60.     end;
  61.  
  62. {$S Util2}
  63.     procedure SegmentUtil2;
  64.     begin
  65.     end;
  66.  
  67. {$S Term}
  68.     procedure SegmentTerm;
  69.     begin
  70.     end;
  71.  
  72. {$S Util}
  73.     function TrapAvailable (tNumber: INTEGER): BOOLEAN;
  74. {Check to see if a given trap is implemented. Babble as taken from IM6 }
  75.         const
  76.             TrapMask = $0800;
  77.         var
  78.             tType: TrapType;
  79.             ignoreError: OSErr;
  80.     begin
  81.         if BAND(tNumber, TrapMask) > 0 then
  82.             tType := ToolTrap
  83.         else
  84.             tType := OSTrap;
  85.         if tType = ToolTrap then begin
  86.             tNumber := BAND(tNumber, $7FF);
  87.             if tNumber >= $400 then
  88.                 tNumber := _Unimplemented
  89.             else if tNumber >= $200 then
  90.                 if NGetTrapAddress($A86E, ToolTrap) <> NGetTrapAddress($AA6E, ToolTrap) then
  91.                     tNumber := _Unimplemented;
  92.         end;
  93.         TrapAvailable := NGetTrapAddress(tNumber, tType) <> GetTrapAddress(_Unimplemented);
  94.     end; {TrapAvailable}
  95.  
  96. {$S Util}
  97.     function MyNumToString (n: longInt): str255;
  98.         var
  99.             s: str255;
  100.     begin
  101.         if abs(n) < 4096 then
  102.             NumToString(n, s)
  103.         else if abs(n) < 4194304 then begin
  104.             NumToString(n div 1024, s);
  105.             s := Concat(s, 'k');
  106.         end
  107.         else begin
  108.             NumToString(n div 1048576, s);
  109.             s := Concat(s, 'M');
  110.         end;
  111.         MyNumToString := s;
  112.     end;
  113.  
  114. {$S Util}
  115.     function NumToStr (n: longInt): str255;
  116.         var
  117.             s: str255;
  118.     begin
  119.         NumToString(n, s);
  120.         NumToStr := s;
  121.     end;
  122.  
  123. {$S Util}
  124.     function NN (n: longInt; len: integer): str31;
  125.         var
  126.             s: str31;
  127.     begin
  128.         s := NumToStr(n);
  129.         while length(s) < len do
  130.             s := concat('0', s);
  131.         NN := s;
  132.     end;
  133.  
  134. {$S Util}
  135.     function StrToNum (s: str255): longInt;
  136.         var
  137.             n: longInt;
  138.     begin
  139.         StringToNum(s, n);
  140.         StrToNum := n;
  141.     end;
  142.  
  143. {$S Util2}
  144.     procedure DotDotDot (var s: str255; var width: integer);
  145.         var
  146.             maxwidth, len: integer;
  147.     begin
  148.         maxwidth := width;
  149.         width := StringWidth(s);
  150.         if width > maxwidth then begin
  151.             width := width + CharWidth('…');
  152. {$PUSH}
  153. {$R-}
  154.             len := ord(s[0]);
  155.             while (len > 0) and (width > maxwidth) do begin
  156.                 width := width - CharWidth(s[len]);
  157.                 len := len - 1;
  158.             end;
  159.             len := len + 1;
  160.             s[0] := chr(len);
  161.             s[len] := '…';
  162. {$POP}
  163.         end;
  164.     end;
  165.  
  166. {$S}
  167.     procedure SetItemEnable (mh: menuHandle; item: integer; enable: boolean);
  168.     begin
  169.         if enable then
  170.             EnableItem(mh, item)
  171.         else
  172.             DisableItem(mh, item);
  173.     end;
  174.  
  175. {$S}
  176.     procedure SetIDItemEnable (menu, item: integer; enable: boolean);
  177.     begin
  178.         SetItemEnable(GetMHandle(menu), item, enable);
  179.     end;
  180.  
  181. {$S}
  182.     function GetItemEnable (mh: menuHandle; item: integer): boolean;
  183.     begin
  184.         if item > 31 then
  185.             GetItemEnable := true
  186.         else
  187.             GetItemEnable := BTST(mh^^.enableFlags, item);
  188.     end;
  189.  
  190. {$S}
  191.     function GetIDItemEnable (menu, item: integer): boolean;
  192.     begin
  193.         GetIDItemEnable := GetItemEnable(GetMHandle(menu), item);
  194.     end;
  195.  
  196. {$S Util2}
  197.     procedure DotItem (mh: menuHandle; item: integer; dotted: boolean);
  198.     begin
  199.         if dotted then
  200.             SetItemMark(mh, item, '•')
  201.         else
  202.             SetItemMark(mh, item, chr(0));
  203.     end;
  204.  
  205. {$S Util2}
  206.     function MyFrontWindow: boolean;
  207.         var
  208.             wp: windowPtr;
  209.     begin
  210.         wp := FrontWindow;
  211.         if wp = nil then
  212.             MyFrontWindow := false
  213.         else
  214.             MyFrontWindow := windowPeek(wp)^.windowKind >= userKind;
  215.     end;
  216.  
  217. {$S Util2}
  218.     function DAFrontWindow: boolean;
  219.         var
  220.             wp: windowPtr;
  221.     begin
  222.         wp := FrontWindow;
  223.         if wp = nil then
  224.             DAFrontWindow := false
  225.         else
  226.             DAFrontWindow := windowPeek(wp)^.windowKind < 0;
  227.     end;
  228.  
  229. {$S Util2}
  230.     function GetIndStrSize (size, id, index: integer): str255;
  231.         var
  232.             s: str255;
  233.     begin
  234.         GetIndString(s, id, index);
  235.         GetIndStrSize := copy(s, 1, size - 1);
  236.     end;
  237.  
  238. {$S Util}
  239.     procedure GetVersion (var vers: versionRecord);
  240.         var
  241.             vh: handle;
  242.             p: integer;
  243.     begin
  244.         with vers do begin
  245.             vh := GetResource('vers', 1);
  246.             if vh = nil then begin
  247.                 version := $0000;
  248.                 devcode := $20;
  249.                 revision := $00;
  250.                 country := 0;
  251.                 short := '0.0.0';
  252.                 long := 'Unknown v0.0.0';
  253.             end
  254.             else begin
  255.                 BlockMove(vh^, @vers, sizeof(vers));
  256.                 BlockMove(Ptr(longint(vh^) + (longint(@short) - longint(@vers)) + length(short) + 1), @long, sizeof(long));
  257.                 if length(short) >= sizeof(short) then
  258. {$PUSH}
  259.  {$R-}
  260.                     short[0] := chr(sizeof(short) - 1);
  261. {$POP}
  262.                 ReleaseResource(vh);
  263.             end;
  264.             p := pos(short, long);
  265.             while (p > 0) & (vers.long[p] <> ' ') do
  266.                 p := p - 1;
  267.             p := p - 1;
  268.             if p < 1 then
  269.                 p := 255;
  270.             name := copy(vers.long, 1, p);
  271.         end;
  272.     end;
  273.  
  274. {$S Util}
  275.     procedure SetVersionParamText (c3: str255);
  276.         var
  277.             vers: versionRecord;
  278.             p: integer;
  279.     begin
  280.         GetVersion(vers);
  281.         ParamText(vers.short, vers.long, vers.name, c3);
  282.     end;
  283.  
  284. {$S Util}
  285.     function GetDirID (wdrn: integer; var vrn: integer; var dirID: longInt): OSErr;
  286.         var
  287.             procID: longInt;
  288.             oe: OSErr;
  289.     begin
  290.         oe := GetWDInfo(wdrn, vrn, dirID, procID);
  291.         if oe <> noErr then begin
  292.             vrn := wdrn;
  293.             dirID := 0;
  294.         end;
  295.         GetDirID := oe;
  296.     end;
  297.  
  298. {$S Util2}
  299.     function GetVolInfo (var name: str63; var vrn: integer; index: integer; var CrDate: longInt): OSErr;
  300.         var
  301.             pb: paramBlockRec;
  302.             oe: OSErr;
  303.     begin
  304.         with pb do begin
  305.             if (name <> '') & (name[length(name)] <> ':') then
  306.                 name := concat(name, ':');
  307.             pb.ioNamePtr := @name;
  308.             ioVRefNum := vrn;
  309.             ioVolIndex := index;
  310.             oe := PBGetVInfo(@pb, false);
  311.             if oe = noErr then begin
  312.                 vrn := ioVRefNum;
  313.                 CrDate := ioVCrDate;
  314.             end;
  315.         end;
  316.         GetVolInfo := oe;
  317.     end;
  318.  
  319. {$S Util}
  320.     procedure PlotSICN (id: integer; index, v, h: integer);
  321.         var
  322.             sh: Handle;
  323.             bm: BitMap;
  324.             r: Rect;
  325.             gp: grafptr;
  326.     begin
  327.         sh := GetResource('SICN', id);
  328.         HLock(sh);
  329.         bm.baseAddr := Ptr(longInt(sh^) + (index - 1) * 32);
  330.         bm.rowBytes := 2;
  331.         SetRect(r, h, v, h + 16, v + 16);
  332.         bm.bounds := r;
  333.         GetPort(gp);
  334.         CopyBits(bm, gp^.portBits, r, r, srcCopy, nil);
  335.         HUnlock(sh);
  336.     end;
  337.  
  338.     function HLockState (h: univ handle): signedByte;
  339.     begin
  340.         HLockState := HGetState(h);
  341.         HLock(h);
  342.     end;
  343.  
  344.     function LookupStrh (id: integer; match: str255): str255;
  345.         var
  346.             t, s: str255;
  347.             i: integer;
  348.     begin
  349.         t := '';
  350.         i := 1;
  351.         repeat
  352.             GetIndString(s, id, i);
  353.             if s = match then begin
  354.                 GetIndString(t, id, i + 1);
  355.                 leave;
  356.             end;
  357.             i := i + 2;
  358.         until s = '';
  359.         LookupStrh := t;
  360.     end;
  361.  
  362.     function LookupStrhNumber (id: integer; n: longInt): str255;
  363.         var
  364.             s, t: str255;
  365.     begin
  366.         NumToString(n, s);
  367.         t := LookupStrh(id, s);
  368.         if t = '' then
  369.             t := s;
  370.         LookupStrhNumber := t;
  371.     end;
  372.  
  373.  
  374.     function TouchDir (fs: FSSpec): OSErr;
  375.         var
  376.             pb: CInfoPBRec;
  377.             oe: OSErr;
  378.     begin
  379.         pb.ioVRefNum := fs.vRefNum;
  380.         pb.ioDrDirID := fs.parID;
  381.         if fs.name = '' then
  382.             pb.ioNamePtr := nil
  383.         else
  384.             pb.ioNamePtr := @fs.name;
  385.         pb.ioFDirIndex := 0;
  386.  
  387.         oe := PBGetCatInfo(@pb, false);
  388.  
  389.         if oe = noErr then begin
  390.  
  391.             pb.ioDrDirID := pb.ioDrParID;
  392.             pb.ioFDirIndex := 0;
  393.             GetDateTime(pb.ioDrMdDat);
  394.  
  395.             oe := PBSetCatInfo(@pb, false);
  396.         end;
  397.  
  398.         TouchDir := oe;
  399.     end;
  400.  
  401.     function CreateUniqueFile (var fs: FSSpec; creator, ftype: OSType): OSErr;
  402.         var
  403.             oname: str31;
  404.             n: str255;
  405.             i: integer;
  406.             oe: OSErr;
  407.     begin
  408.         oname := fs.name;
  409.         oe := HCreate(fs.vRefNum, fs.parID, fs.name, creator, ftype);
  410.         i := 1;
  411.         while oe = dupFNErr do begin
  412.             NumToString(i, n);
  413.             fs.name := concat(copy(oname, 1, 27), '#', n);
  414.             oe := HCreate(fs.vRefNum, fs.parID, fs.name, creator, ftype);
  415.             i := i + 1;
  416.         end;
  417.         CreateUniqueFile := oe;
  418.     end;
  419.  
  420.     function MyFSWrite (refnum: integer; len: longInt; p: ptr): OSErr;
  421.         var
  422.             oe: OSErr;
  423.             count: longInt;
  424.     begin
  425.         oe := noErr;
  426.         if len > 0 then begin
  427.             count := len;
  428.             oe := FSWrite(refnum, count, p);
  429.             if (oe = noErr) & (count <> len) then
  430.                 oe := -1;
  431.         end;
  432.         MyFSWrite := oe;
  433.     end;
  434.  
  435. end.